
> ################
> #PSRM: Explaining Support for Redistribution: Social Insurance Systems and Fairness
> #
> #Experimental Data
> #Figure 4
> #
> #Verena Fetscher
> #July 2022
> ####################
> 
> 
> 
> ##########################
> #Load data file
> ##########################
> 
> load("dataLab_SocialInsurance_complete.Rda")

> ##########################
> #Filter for decision-makers
> ##########################
> 
> dfSub<-df[df$Role==1,]

> ##########################
> #Subgroups
> ##########################
> 
> #Segregate types
> types<-aggregate(rep(1, length(paste0(dfSub$give_weight,dfSub$ID,dfSub$Role))),
+                  by=list(dfSub$give_weight,dfSub$ID,dfSub$Role), sum)

> filter(types,Group.3==1)
        Group.1 Group.2 Group.3  x
1     0.0000000       1       1 15
2     2.9985563       1       1  1
3     0.0000000       2       1 16
4    33.1223011       3       1  1
5    35.9826750       3       1  1
6    47.9769000       3       1  1
7    53.5594656       3       1  1
8    53.9740125       3       1  1
9    53.9740125       3       1  1
10   55.4732906       3       1  2
11   56.3783848       3       1  1
12   56.9725688       3       1  1
13   57.0831146       3       1  1
14   58.4718469       3       1  1
15   61.3114935       3       1  1
16   62.2200422       3       1  1
17   63.7193203       3       1  1
18   65.9682375       3       1  1
19    0.0000000       4       1 14
20   35.2330359       4       1  1
21   40.8743290       4       1  1
22    0.0000000       5       1  7
23   31.4848406       5       1  1
24   86.2084922       5       1  1
25   88.7959561       5       1  1
26   90.7063266       5       1  1
27   90.9101455       5       1  1
28   94.4337945       5       1  1
29   95.9538000       5       1  1
30  100.0716330       5       1  1
31  100.4516344       5       1  1
32   15.7424203       6       1  1
33   17.9913375       6       1  1
34   20.2402547       6       1  1
35   35.9826750       6       1  1
36   37.4819531       6       1  1
37   47.2272609       6       1  1
38   50.9754563       6       1  1
39   52.4747344       6       1  1
40   53.9740125       6       1  2
41   57.7878444       6       1  1
42   60.6067637       6       1  1
43   61.3114935       6       1  1
44   62.0162233       6       1  1
45   62.0162233       6       1  1
46   62.2200422       6       1  1
47    0.0000000       7       1 16
48    0.0000000       8       1  1
49    3.7481953       8       1  1
50   13.3898664       8       1  1
51   14.9927813       8       1  2
52   20.9898938       8       1  1
53   21.8466241       8       1  1
54   28.4862844       8       1  1
55   34.4833969       8       1  1
56   37.3506799       8       1  1
57   50.2258172       8       1  1
58   53.9740125       8       1  1
59   63.7193203       8       1  1
60   73.2919002       8       1  1
61   85.2723070       8       1  1
62   85.4588531       8       1  1
63   10.5709472       9       1  1
64   14.9927813       9       1  1
65   17.9913375       9       1  1
66   25.3702732       9       1  1
67   28.4862844       9       1  1
68   29.2359234       9       1  1
69   31.4848406       9       1  1
70   33.1223011       9       1  1
71   56.2229297       9       1  1
72   57.7878444       9       1  1
73   60.7207641       9       1  2
74   62.7209531       9       1  1
75   65.9682375       9       1  1
76   67.4675156       9       1  1
77   98.9523563       9       1  1
78    6.3425683      20       1  1
79   13.4935031      20       1  1
80   15.7424203      20       1  1
81   16.4920594      20       1  1
82   17.6182453      20       1  1
83   20.2402547      20       1  1
84   20.9898938      20       1  1
85   21.7395328      20       1  1
86   26.2373672      20       1  1
87   28.4862844      20       1  1
88   31.4848406      20       1  1
89   32.2344797      20       1  1
90   38.0554097      20       1  1
91   38.7601396      20       1  1
92   50.9754563      20       1  1
93   54.9689252      20       1  1
94    0.0000000      21       1 16
95    0.0000000      22       1 16
96    0.0000000      23       1  1
97    6.3425683      23       1  1
98   10.4949469      23       1  1
99   11.9804068      23       1  1
100  11.9942250      23       1  1
101  14.0945962      23       1  1
102  26.9870063      23       1  1
103  32.4175713      23       1  1
104  34.4833969      23       1  1
105  38.9812313      23       1  1
106  59.2214860      23       1  1
107  64.4689594      23       1  1
108  70.4660719      23       1  1
109  83.2099360      23       1  1
110  89.2070485      23       1  1
111  99.7019953      23       1  1
112   0.0000000      24       1 16
113   0.0000000      25       1  5
114   1.4992781      25       1  1
115   2.1141894      25       1  1
116   2.2489172      25       1  1
117   2.8189192      25       1  3
118   2.9985563      25       1  1
119   3.7481953      25       1  1
120   5.2474734      25       1  1
121   5.2474734      25       1  2
122   2.8189192      26       1  1
123   5.2474734      26       1  1
124   6.7467516      26       1  1
125   8.4567577      26       1  1
126  10.4949469      26       1  1
127  12.7438641      26       1  1
128  14.9927813      26       1  1
129  21.7395328      26       1  1
130  23.2388109      26       1  1
131  23.9608135      26       1  1
132  23.9884500      26       1  1
133  48.7265391      26       1  1
134  55.6736550      26       1  1
135  71.2157110      26       1  1
136 101.4810927      26       1  1
137 119.1926110      26       1  1
138   1.4094596      27       1  1
139   1.4094596      27       1  1
140   2.1141894      27       1  1
141   2.9985563      27       1  2
142   2.9985563      27       1  1
143   3.7481953      27       1  1
144   4.2283789      27       1  1
145   5.2474734      27       1  1
146   6.7467516      27       1  1
147   7.4963906      27       1  1
148  11.9804068      27       1  1
149  11.9942250      27       1  2
150  23.2388109      27       1  1
151  24.7380891      27       1  1
152   0.0000000      28       1  1
153   4.4978344      28       1  1
154   7.7520279      28       1  1
155  11.2445859      28       1  1
156  11.2756770      28       1  1
157  11.9804068      28       1  1
158  11.9804068      28       1  1
159  17.2416984      28       1  1
160  17.9913375      28       1  1
161  22.5513539      28       1  1
162  24.7380891      28       1  1
163  35.2330359      28       1  1
164  35.9826750      28       1  2
165  47.2272609      28       1  1
166  71.9653500      28       1  1
167   0.0000000      29       1  2
168   2.2489172      29       1  1
169   8.2460297      29       1  1
170  11.9942250      29       1  1
171  12.7438641      29       1  1
172  14.2431422      29       1  2
173  15.5040558      29       1  1
174  15.7424203      29       1  1
175  16.2087856      29       1  1
176  21.8466241      29       1  1
177  21.8466241      29       1  1
178  23.2388109      29       1  1
179  23.2560837      29       1  1
180  24.7380891      29       1  1
181   0.0000000      30       1  2
182  71.9653500      30       1  1
183  72.5871704      30       1  1
184  73.2919002      30       1  1
185  76.4631844      30       1  1
186  82.4602969      30       1  1
187  84.5675772      30       1  1
188  87.7077703      30       1  2
189  95.1385244      30       1  1
190  97.4530781      30       1  1
191  99.7019953      30       1  1
192 100.4516344      30       1  2
193 102.7005516      30       1  1
194  20.9898938      42       1  1
195  30.7352016      42       1  1
196  31.4848406      42       1  1
197  31.4848406      42       1  1
198  32.2344797      42       1  1
199  34.4833969      42       1  1
200  35.2364905      42       1  1
201  38.7601396      42       1  1
202  40.1695992      42       1  1
203  43.4790656      42       1  1
204  53.2243734      42       1  1
205  60.7207641      42       1  1
206  66.7178766      42       1  1
207  68.2171547      42       1  1
208  76.1108195      42       1  1
209  77.5202791      42       1  1
210   0.0000000      43       1 12
211   1.4094596      43       1  1
212   1.4992781      43       1  1
213   2.8189192      43       1  1
214   2.9985563      43       1  1
215   0.0000000      44       1  3
216   1.4094596      44       1  1
217   2.1141894      44       1  1
218   2.2489172      44       1  4
219   2.8189192      44       1  1
220   2.8189192      44       1  1
221   2.9985563      44       1  2
222   2.9985563      44       1  1
223  11.2445859      44       1  1
224  15.5040558      44       1  1
225   0.0000000      45       1 16
226   0.0000000      46       1  1
227   2.2489172      46       1  1
228   2.8189192      46       1  1
229   3.7481953      46       1  1
230   4.9331087      46       1  1
231   6.7467516      46       1  1
232   7.4963906      46       1  1
233   9.1614875      46       1  1
234   9.7453078      46       1  1
235  11.2445859      46       1  1
236  11.9942250      46       1  1
237  12.6851366      46       1  1
238  14.0945962      46       1  1
239  14.2431422      46       1  1
240  16.4920594      46       1  1
241  16.4920594      46       1  1
242   0.0000000      47       1 13
243   0.7047298      47       1  2
244   0.7496391      47       1  1
245  15.7424203      48       1  1
246  20.4371645      48       1  1
247  23.2388109      48       1  1
248  57.7878444      48       1  1
249  62.9696813      48       1  1
250  77.9624625      48       1  1
 [ reached 'max' / getOption("max.print") -- omitted 614 rows ]

> length(filter(types,Group.1==0&Group.3==1&x>=5)$Group.2)
[1] 37

> length(filter(types,Group.1==0&Group.3==1&x>=8)$Group.2)
[1] 28

> length(filter(types,Group.1==0&Group.3==1&x>=16)$Group.2)
[1] 19

> x<-filter(types,Group.1==0&Group.3==1&x>=5)

> x$Group.2
 [1]   1   2   4   5   7  21  22  24  25  43  45  47  50  64  69  80  81  97 105 106 107 108
[23] 110 118 119 123 124 139 141 144 145 156 157 158 159 160 161

> ##########################
> #Other-regarding decision-makers
> ##########################
> 
> #remove decision-makers with 4 or more zero transfers from data set
> dfSub_other<-dfSub[!(dfSub$ID %in% x$Group.2),] 

> length(unique(dfSub_other$ID))
[1] 50

> dfSub %>%
+   filter(!(dfSub$ID %in% x$Group.2)) %>%
+   group_by(ID) %>%
+   summarize(mean= mean(give_weight))-> mydf_other

> summary(mydf_other$mean)
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  2.673  16.379  31.762  36.223  52.935  89.605 

> sd(mydf_other$mean)
[1] 24.0636

> ##########################
> #Comparison benefit-level principle
> ##########################
> 
> 
> #Comparison 1
> #Situations
> #2-9
> 
> length(unique(dfSub_other$ID))
[1] 50

> sit1<-dfSub_other$situation==2

> sit2<-dfSub_other$situation==9

> s1 <- dfSub_other$give_weight[sit1]

> s2 <- dfSub_other$give_weight[sit2]

> mean(dfSub_other$give_weight[sit1],na.rm=T)-
+ mean(dfSub_other$give_weight[sit2],na.rm=T)
[1] 10.778

> #Nonparametric test statistics
> p<-wilcoxsign_test(s1~s2,data=dfSub_other,
+                    distribution="exact") 

> p<-paste("p =",as.character(round(pvalue(p),4)), sep=" ")

> g1<-ggplot(data=dfSub_other[sit1|sit2,], 
+        aes(x=factor(situation), give_weight))+
+   geom_boxplot(aes(fill=factor(situation)),width=.5,alpha=.8)+
+   stat_summary(fun.y = mean, geom="point",color="black",size=3) +
+   stat_summary(fun.y=mean, colour="black", geom="text", show_guide= FALSE, 
+                vjust=-.7, aes( label=round(..y.., digits=2))) +
+   ylab("Inequality-reduction in %") +  xlab ("")+ ylim(c(0,200))+
+   ggtitle("(a) Absolute\n endowment")+
+   theme_minimal()+
+   scale_fill_manual(values=c("#CCCCCC","#666666"), 
+                    name="",
+                    breaks=c("2","9"),
+                    labels=c("earnings-related",
+                              "flat-rate"))+
+   guides(fill=guide_legend(nrow=2,byrow=TRUE))+
+   annotate("text", x=1.5, y=117.5, label= p,size=5)+
+   theme_bw()+
+   theme(panel.border=element_blank(),axis.line=element_line(),
+         plot.title = element_text(size=20),
+         legend.text = element_text(size = 18),
+         legend.title = element_text(size=18),
+         axis.text=element_text(size=18),
+         axis.title=element_text(size=18),
+         axis.text.x = element_blank(),
+         axis.text.y=element_text(size=18),
+         legend.position="none"
+   )

> #Comparison 2
> #Situations
> #8-13
> 
> sit1<-dfSub_other$situation==8

> sit2<-dfSub_other$situation==13

> s1 <- dfSub_other$give_weight[sit1]

> s2 <- dfSub_other$give_weight[sit2]

> mean(dfSub_other$give_weight[sit1],na.rm=T)-
+ mean(dfSub_other$give_weight[sit2],na.rm=T)
[1] 8.064643

> #Nonparametric test statistics
> p<-wilcoxsign_test(s1~s2,data=dfSub_other,
+                    distribution="approximate") 

> p<-paste("p =",as.character(round(pvalue(p),4)), sep=" ")

> g2<-ggplot(data=dfSub_other[sit1|sit2,], 
+        aes(x=factor(situation), give_weight))+
+   #geom_violin()+
+   geom_boxplot(aes(fill=factor(situation)),width=.5,alpha=.8)+
+   stat_summary(fun.y = mean, geom="point",color="black",size=3) +
+   stat_summary(fun.y=mean, colour="black", geom="text", show_guide= FALSE, 
+                vjust=-.7, aes( label=round(..y.., digits=2))) +
+   ylab("") +  xlab ("")+ 
+   ggtitle("(b) Inequality and\nhigh replacement")+ylim(c(0,200))+
+   scale_fill_manual(values=c("#CCCCCC","#666666"), 
+                     name="",
+                     breaks=c("8","13"),
+                     labels=c("earnings-related",
+                              "flat-rate"))+
+   guides(fill=guide_legend(nrow=2,byrow=TRUE))+
+   annotate("text", x=1.5, y=117.5, label= p,size=5)+
+   theme_bw()+
+   theme(panel.border=element_blank(),axis.line=element_line(),
+         plot.title = element_text(size=20),
+         legend.text = element_text(size = 18),
+         legend.title = element_text(size=18),
+         axis.text=element_text(size=18),
+         axis.title=element_text(size=18),axis.text.x = element_blank(),axis.text.y=element_blank(),
+         legend.position="none"
+   )

> #Comparison 3
> #Situations
> #6-13
> 
> sit1<-dfSub_other$situation==6

> sit2<-dfSub_other$situation==13

> s1 <- dfSub_other$give_weight[sit1]

> s2 <- dfSub_other$give_weight[sit2]

> mean(dfSub_other$give_weight[sit1],na.rm=T)-
+ mean(dfSub_other$give_weight[sit2],na.rm=T)
[1] 5.870815

> #nonparametric test statistics
> p<-wilcoxsign_test(s1~s2,data=dfSub_other,
+                    distribution="exact") 

> p<-paste("p =",as.character(round(pvalue(p),4)), sep=" ")

> g3<-ggplot(data=dfSub_other[sit1|sit2,], 
+        aes(x=factor(situation), give_weight))+
+   geom_boxplot(aes(fill=factor(situation)),width=.5,alpha=.8)+
+   stat_summary(fun.y = mean, geom="point",color="black",size=3) +
+   stat_summary(fun.y=mean, colour="black", geom="text", show_guide= FALSE, 
+                vjust=-.7, aes( label=round(..y.., digits=2))) +
+   ylab("") +  xlab ("")+ ylim(c(0,200))+
+   ggtitle("(c) Inequality and\nlow replacement")+
+   theme_minimal()+
+   scale_fill_manual(values=c("#CCCCCC","#666666"), 
+                     name="",
+                     breaks=c("6","13"),
+                     labels=c("earnings-related",
+                              "flat-rate"))+
+   guides(fill=guide_legend(nrow=2,byrow=TRUE))+
+   annotate("text", x=1.5, y=117.5, label= p,size=5)+
+   theme_bw()+
+   theme(panel.border=element_blank(),axis.line=element_line(),
+         plot.title = element_text(size=20),
+         legend.text = element_text(size = 18),
+         legend.title = element_text(size=18),
+         axis.text=element_text(size=18),
+         axis.title=element_text(size=18),
+         axis.text.x = element_blank(),
+         axis.text.y=element_blank(),
+         legend.position="none"
+   )

> #Produces Figure 4: Effect of social insurance principle on transfers.
> ggarrange(g1,g2, g3,common.legend = TRUE, legend="bottom",ncol = 3)

> ggsave(file="figure_4.pdf", height = 5.83, width = 8.27, units = "in")

> ################
> #PSRM: Explaining Support for Redistribution: Social Insurance Systems and Fairness
> #
> #Experimental Data
> #Table D 7
> #
> #Verena Fetscher
> #July 2022
> ####################
> 
> 
> 
> 
> ##########################
> #Load data file
> ##########################
> 
> load("dataLab_SocialInsurance_complete.Rda")

> ##########################
> #Descriptive statistics
> ##########################
> 
> 
> n<-c(as.numeric(table(is.na(df$age))/16)[1],
+ as.numeric(table(is.na(df$income_fam))/16)[1],
+ as.numeric(table(is.na(df$redistribution))/16)[1],
+ as.numeric(table(is.na(df$polint))/16)[1],
+ as.numeric(table(is.na(df$leftright))/16)[1],
+ as.numeric(table(is.na(df$instructions))/16)[1],
+ as.numeric(table(is.na(df$change))/16)[1],
+ as.numeric(table(is.na(df$numclicks))/16)[1],
+ as.numeric(table(is.na(df$gender))/16)[1],
+ as.numeric(table(is.na(df$religion))/16)[1])

> df %>%
+   summarize(age = min(age,na.rm=T),
+             income_fam=min(income_fam,na.rm=T),
+             redistribution=min(redistribution,na.rm=T),
+             polint=min(polint,na.rm=T),
+             leftright=min(leftright,na.rm=T),
+             instructions=min(instructions,na.rm=T),
+             change=min(change,na.rm=T),
+             clicks=min(numclicks,na.rm=T),
+             gender=min(gender, na.rm=T),
+             religion=min(religion,na.rm=T)
+   ) -> descr_min

> df %>%
+   summarize(age = max(age,na.rm=T),
+             income_fam=max(income_fam,na.rm=T),
+             redistribution=max(redistribution,na.rm=T),
+             polint=max(polint,na.rm=T),
+             leftright=max(leftright,na.rm=T),
+             instructions=max(instructions,na.rm=T),
+             change=max(change,na.rm=T),
+             clicks=max(numclicks,na.rm=T),
+             gender=max(gender, na.rm=T),
+             religion=max(religion,na.rm=T)
+   ) -> descr_max

> df %>%
+   summarize(age = mean(age,na.rm=T),
+             income_fam=mean(income_fam,na.rm=T),
+             redistribution=mean(redistribution,na.rm=T),
+             polint=mean(polint,na.rm=T),
+             leftright=mean(leftright,na.rm=T),
+             instructions=mean(instructions,na.rm=T),
+             change=mean(change,na.rm=T),
+             clicks=mean(numclicks,na.rm=T),
+             gender=mean(gender, na.rm=T),
+             religion=mean(religion,na.rm=T)
+   ) -> descr_mean

> df %>%
+   summarize(age = sd(age,na.rm=T),
+             income_fam=sd(income_fam,na.rm=T),
+             redistribution=sd(redistribution,na.rm=T),
+             polint=sd(polint,na.rm=T),
+             leftright=sd(leftright,na.rm=T),
+             instructions=sd(instructions,na.rm=T),
+             change=sd(change,na.rm=T),
+             clicks=sd(numclicks,na.rm=T),
+             gender=sd(gender, na.rm=T),
+             religion=sd(religion,na.rm=T)
+   ) -> descr_sd

> dfDescr<-data.frame(rbind(n,descr_min, descr_max,descr_mean,descr_sd))

> data.frame(dfDescr)
         age  income_fam redistribution      polint  leftright instructions     change
1 170.000000 170.0000000    170.0000000 170.0000000 171.000000   173.000000 174.000000
2  18.000000   1.0000000      1.0000000   1.0000000   1.000000     1.000000   1.000000
3  59.000000   5.0000000      5.0000000   4.0000000  10.000000     9.000000   6.000000
4  22.729412   2.3470588      2.4352941   2.0588235   5.304094     2.884393   4.971264
5   4.556089   0.8696544      0.9757282   0.8312108   1.707173     2.095912   1.233981
      clicks      gender    religion
1 174.000000 174.0000000 172.0000000
2   1.000000   0.0000000   0.0000000
3  46.000000   1.0000000   1.0000000
4   4.041307   0.5344828   0.4883721
5   3.837250   0.4988991   0.4999556

> rownames(dfDescr)<-c("N","Min","Max","Mean","SD")

> colnames(dfDescr)<-c("Age","Family income","Redistribution","Interested in politics","Leftright",
+                      "Instructions","Make changes in transfer decisions","Number of clicks (transfer decision)","Female",
+                      "Member religious community")

> ##########################
> #Table D.7: Descriptive statistics. Means, standard deviations, and percentages.
> ##########################
> xtable(t(dfDescr), caption="Descriptive Statistics. Means, standard deviations, and percentages.")
% latex table generated in R 4.0.4 by xtable 1.8-4 package
% Wed Aug 10 16:49:15 2022
\begin{table}[ht]
\centering
\begin{tabular}{rrrrrr}
  \hline
 & N & Min & Max & Mean & SD \\ 
  \hline
Age & 170.00 & 18.00 & 59.00 & 22.73 & 4.56 \\ 
  Family income & 170.00 & 1.00 & 5.00 & 2.35 & 0.87 \\ 
  Redistribution & 170.00 & 1.00 & 5.00 & 2.44 & 0.98 \\ 
  Interested in politics & 170.00 & 1.00 & 4.00 & 2.06 & 0.83 \\ 
  Leftright & 171.00 & 1.00 & 10.00 & 5.30 & 1.71 \\ 
  Instructions & 173.00 & 1.00 & 9.00 & 2.88 & 2.10 \\ 
  Make changes in transfer decisions & 174.00 & 1.00 & 6.00 & 4.97 & 1.23 \\ 
  Number of clicks (transfer decision) & 174.00 & 1.00 & 46.00 & 4.04 & 3.84 \\ 
  Female & 174.00 & 0.00 & 1.00 & 0.53 & 0.50 \\ 
  Member religious community & 172.00 & 0.00 & 1.00 & 0.49 & 0.50 \\ 
   \hline
\end{tabular}
\caption{Descriptive Statistics. Means, standard deviations, and percentages.} 
\end{table}

> ################
> #PSRM: Explaining Support for Redistribution: Social Insurance Systems and Fairness
> #
> #Experimental Data
> #Figure D 17
> #
> #Verena Fetscher
> #July 2022
> ####################
> 
> 
> 
> ##########################
> #Load data file
> ##########################
> 
> load("dataLab_SocialInsurance_complete.Rda")

> ##########################
> #Filter for decision-makers
> ##########################
> 
> dfSub<-df[df$Role==1,]

> ##########################
> #Average transfers among decision-makers
> ##########################
> 
> # Provides information in main text (Section Other-Regarding Preferences Matter)
> dfSub %>%
+   group_by(ID) %>%
+   summarize(mean= mean(give_weight))-> mydf

> summary(mydf$mean)
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  0.000   0.164  16.114  23.184  40.347  89.605 

> sd(mydf$mean)
[1] 24.82719

> unique(length(mydf$ID))
[1] 87

> m<-paste("median =",as.character(round(median(mydf$mean),2)), sep=" ")

> y<-median(mydf$mean)+4

> ##########################
> #Figure D.17: Average transfers by decision-makers.
> ##########################
> 
> mydf %>%
+   group_by(ID) %>%                            
+   summarize(mean = mean) %>%
+   arrange(+mean) %>%                               
+   mutate(group = factor(ID, ID)) %>%   
+   ggplot(aes(x=group, y=mean)) +                 
+   geom_bar(stat="identity", fill = "white", colour = "black")+
+   geom_hline(aes(yintercept = median(mean)),linetype="dashed")+
+   annotate("text", x = 30, y = y, label =  m)+
+   xlab("Subject") + ylab("Inequality-reduction in %") +
+   scale_y_continuous(expand = c(0, 0)) + 
+   theme_bw()+
+   theme(panel.border=element_blank(),axis.line=element_line(),
+         legend.position="bottom",legend.text = element_text(size = 14),
+         legend.title = element_text(size=14),axis.text=element_text(size=12),
+         axis.title=element_text(size=14),axis.text.x = element_blank()
+   )

> ggsave(file="figure_d17.pdf", height = 5.83, width = 8.27, units = "in")

> ################
> #PSRM: Explaining Support for Redistribution: Social Insurance Systems and Fairness
> #
> #Experimental Data
> #Figure D 18
> #
> #Verena Fetscher
> #July 2022
> ####################
> 
> 
> 
> ##########################
> #Load data file
> ##########################
> 
> load("dataLab_SocialInsurance_complete.Rda")

> ##########################
> #Filter for decision-makers
> ##########################
> 
> dfSub<-df[df$Role==1,]

> ##########################
> #Subgroups
> ##########################
> 
> #Segregate types
> types<-aggregate(rep(1, length(paste0(dfSub$give_weight,dfSub$ID,dfSub$Role))),
+                  by=list(dfSub$give_weight,dfSub$ID,dfSub$Role), sum)

> filter(types,Group.3==1)
        Group.1 Group.2 Group.3  x
1     0.0000000       1       1 15
2     2.9985563       1       1  1
3     0.0000000       2       1 16
4    33.1223011       3       1  1
5    35.9826750       3       1  1
6    47.9769000       3       1  1
7    53.5594656       3       1  1
8    53.9740125       3       1  1
9    53.9740125       3       1  1
10   55.4732906       3       1  2
11   56.3783848       3       1  1
12   56.9725688       3       1  1
13   57.0831146       3       1  1
14   58.4718469       3       1  1
15   61.3114935       3       1  1
16   62.2200422       3       1  1
17   63.7193203       3       1  1
18   65.9682375       3       1  1
19    0.0000000       4       1 14
20   35.2330359       4       1  1
21   40.8743290       4       1  1
22    0.0000000       5       1  7
23   31.4848406       5       1  1
24   86.2084922       5       1  1
25   88.7959561       5       1  1
26   90.7063266       5       1  1
27   90.9101455       5       1  1
28   94.4337945       5       1  1
29   95.9538000       5       1  1
30  100.0716330       5       1  1
31  100.4516344       5       1  1
32   15.7424203       6       1  1
33   17.9913375       6       1  1
34   20.2402547       6       1  1
35   35.9826750       6       1  1
36   37.4819531       6       1  1
37   47.2272609       6       1  1
38   50.9754563       6       1  1
39   52.4747344       6       1  1
40   53.9740125       6       1  2
41   57.7878444       6       1  1
42   60.6067637       6       1  1
43   61.3114935       6       1  1
44   62.0162233       6       1  1
45   62.0162233       6       1  1
46   62.2200422       6       1  1
47    0.0000000       7       1 16
48    0.0000000       8       1  1
49    3.7481953       8       1  1
50   13.3898664       8       1  1
51   14.9927813       8       1  2
52   20.9898938       8       1  1
53   21.8466241       8       1  1
54   28.4862844       8       1  1
55   34.4833969       8       1  1
56   37.3506799       8       1  1
57   50.2258172       8       1  1
58   53.9740125       8       1  1
59   63.7193203       8       1  1
60   73.2919002       8       1  1
61   85.2723070       8       1  1
62   85.4588531       8       1  1
63   10.5709472       9       1  1
64   14.9927813       9       1  1
65   17.9913375       9       1  1
66   25.3702732       9       1  1
67   28.4862844       9       1  1
68   29.2359234       9       1  1
69   31.4848406       9       1  1
70   33.1223011       9       1  1
71   56.2229297       9       1  1
72   57.7878444       9       1  1
73   60.7207641       9       1  2
74   62.7209531       9       1  1
75   65.9682375       9       1  1
76   67.4675156       9       1  1
77   98.9523563       9       1  1
78    6.3425683      20       1  1
79   13.4935031      20       1  1
80   15.7424203      20       1  1
81   16.4920594      20       1  1
82   17.6182453      20       1  1
83   20.2402547      20       1  1
84   20.9898938      20       1  1
85   21.7395328      20       1  1
86   26.2373672      20       1  1
87   28.4862844      20       1  1
88   31.4848406      20       1  1
89   32.2344797      20       1  1
90   38.0554097      20       1  1
91   38.7601396      20       1  1
92   50.9754563      20       1  1
93   54.9689252      20       1  1
94    0.0000000      21       1 16
95    0.0000000      22       1 16
96    0.0000000      23       1  1
97    6.3425683      23       1  1
98   10.4949469      23       1  1
99   11.9804068      23       1  1
100  11.9942250      23       1  1
101  14.0945962      23       1  1
102  26.9870063      23       1  1
103  32.4175713      23       1  1
104  34.4833969      23       1  1
105  38.9812313      23       1  1
106  59.2214860      23       1  1
107  64.4689594      23       1  1
108  70.4660719      23       1  1
109  83.2099360      23       1  1
110  89.2070485      23       1  1
111  99.7019953      23       1  1
112   0.0000000      24       1 16
113   0.0000000      25       1  5
114   1.4992781      25       1  1
115   2.1141894      25       1  1
116   2.2489172      25       1  1
117   2.8189192      25       1  3
118   2.9985563      25       1  1
119   3.7481953      25       1  1
120   5.2474734      25       1  1
121   5.2474734      25       1  2
122   2.8189192      26       1  1
123   5.2474734      26       1  1
124   6.7467516      26       1  1
125   8.4567577      26       1  1
126  10.4949469      26       1  1
127  12.7438641      26       1  1
128  14.9927813      26       1  1
129  21.7395328      26       1  1
130  23.2388109      26       1  1
131  23.9608135      26       1  1
132  23.9884500      26       1  1
133  48.7265391      26       1  1
134  55.6736550      26       1  1
135  71.2157110      26       1  1
136 101.4810927      26       1  1
137 119.1926110      26       1  1
138   1.4094596      27       1  1
139   1.4094596      27       1  1
140   2.1141894      27       1  1
141   2.9985563      27       1  2
142   2.9985563      27       1  1
143   3.7481953      27       1  1
144   4.2283789      27       1  1
145   5.2474734      27       1  1
146   6.7467516      27       1  1
147   7.4963906      27       1  1
148  11.9804068      27       1  1
149  11.9942250      27       1  2
150  23.2388109      27       1  1
151  24.7380891      27       1  1
152   0.0000000      28       1  1
153   4.4978344      28       1  1
154   7.7520279      28       1  1
155  11.2445859      28       1  1
156  11.2756770      28       1  1
157  11.9804068      28       1  1
158  11.9804068      28       1  1
159  17.2416984      28       1  1
160  17.9913375      28       1  1
161  22.5513539      28       1  1
162  24.7380891      28       1  1
163  35.2330359      28       1  1
164  35.9826750      28       1  2
165  47.2272609      28       1  1
166  71.9653500      28       1  1
167   0.0000000      29       1  2
168   2.2489172      29       1  1
169   8.2460297      29       1  1
170  11.9942250      29       1  1
171  12.7438641      29       1  1
172  14.2431422      29       1  2
173  15.5040558      29       1  1
174  15.7424203      29       1  1
175  16.2087856      29       1  1
176  21.8466241      29       1  1
177  21.8466241      29       1  1
178  23.2388109      29       1  1
179  23.2560837      29       1  1
180  24.7380891      29       1  1
181   0.0000000      30       1  2
182  71.9653500      30       1  1
183  72.5871704      30       1  1
184  73.2919002      30       1  1
185  76.4631844      30       1  1
186  82.4602969      30       1  1
187  84.5675772      30       1  1
188  87.7077703      30       1  2
189  95.1385244      30       1  1
190  97.4530781      30       1  1
191  99.7019953      30       1  1
192 100.4516344      30       1  2
193 102.7005516      30       1  1
194  20.9898938      42       1  1
195  30.7352016      42       1  1
196  31.4848406      42       1  1
197  31.4848406      42       1  1
198  32.2344797      42       1  1
199  34.4833969      42       1  1
200  35.2364905      42       1  1
201  38.7601396      42       1  1
202  40.1695992      42       1  1
203  43.4790656      42       1  1
204  53.2243734      42       1  1
205  60.7207641      42       1  1
206  66.7178766      42       1  1
207  68.2171547      42       1  1
208  76.1108195      42       1  1
209  77.5202791      42       1  1
210   0.0000000      43       1 12
211   1.4094596      43       1  1
212   1.4992781      43       1  1
213   2.8189192      43       1  1
214   2.9985563      43       1  1
215   0.0000000      44       1  3
216   1.4094596      44       1  1
217   2.1141894      44       1  1
218   2.2489172      44       1  4
219   2.8189192      44       1  1
220   2.8189192      44       1  1
221   2.9985563      44       1  2
222   2.9985563      44       1  1
223  11.2445859      44       1  1
224  15.5040558      44       1  1
225   0.0000000      45       1 16
226   0.0000000      46       1  1
227   2.2489172      46       1  1
228   2.8189192      46       1  1
229   3.7481953      46       1  1
230   4.9331087      46       1  1
231   6.7467516      46       1  1
232   7.4963906      46       1  1
233   9.1614875      46       1  1
234   9.7453078      46       1  1
235  11.2445859      46       1  1
236  11.9942250      46       1  1
237  12.6851366      46       1  1
238  14.0945962      46       1  1
239  14.2431422      46       1  1
240  16.4920594      46       1  1
241  16.4920594      46       1  1
242   0.0000000      47       1 13
243   0.7047298      47       1  2
244   0.7496391      47       1  1
245  15.7424203      48       1  1
246  20.4371645      48       1  1
247  23.2388109      48       1  1
248  57.7878444      48       1  1
249  62.9696813      48       1  1
250  77.9624625      48       1  1
 [ reached 'max' / getOption("max.print") -- omitted 614 rows ]

> length(filter(types,Group.1==0&Group.3==1&x>=5)$Group.2)
[1] 37

> length(filter(types,Group.1==0&Group.3==1&x>=8)$Group.2)
[1] 28

> length(filter(types,Group.1==0&Group.3==1&x>=16)$Group.2)
[1] 19

> x<-filter(types,Group.1==0&Group.3==1&x>=5)

> x$Group.2
 [1]   1   2   4   5   7  21  22  24  25  43  45  47  50  64  69  80  81  97 105 106 107 108
[23] 110 118 119 123 124 139 141 144 145 156 157 158 159 160 161

> ##########################
> #Selfish decision-makers
> ##########################
> 
> #keep decision-makers with 4 or more zero transfers from data set
> dfSub_self<-dfSub[(dfSub$ID %in% x$Group.2),] 

> length(unique(dfSub_self$ID))
[1] 37

> dfSub %>%
+   filter((dfSub$ID %in% x$Group.2)) %>%
+   group_by(ID) %>%
+   summarize(mean= mean(give_weight))-> mydf_self

> summary(mydf_self$mean)
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  0.000   0.000   0.000   5.564   2.301  48.689 

> sd(mydf_self$mean)
[1] 11.3627

> ##########################
> #Comparison benefit-level principle
> ##########################
> 
> 
> #Comparison 1
> #Situations
> #2-9
> 
> 
> sit1<-dfSub_self$situation==2

> sit2<-dfSub_self$situation==9

> s1 <- dfSub_self$give_weight[sit1]

> s2 <- dfSub_self$give_weight[sit2]

> mean(dfSub_self$give_weight[sit1],na.rm=T)-
+   mean(dfSub_self$give_weight[sit2],na.rm=T)
[1] -4.060961

> #Nonparametric test statistics
> p<-wilcoxsign_test(s1~s2,data=dfSub_self,
+                    distribution="exact") 

> p<-paste("p =",as.character(round(pvalue(p),4)), sep=" ")

> g1<-ggplot(data=dfSub_self[sit1|sit2,], 
+            aes(x=factor(situation), give_weight))+
+   geom_boxplot(aes(fill=factor(situation)),width=.5,alpha=.8)+
+   stat_summary(fun.y = mean, geom="point",color="white",size=3) +
+   ylab("Inequality-reduction in %") +  xlab ("")+ ylim(c(0,120))+
+   ggtitle("(a) Absolute endowment\n")+
+   theme_minimal()+
+   scale_fill_manual(values=c("#CCCCCC","#666666"), 
+                     name="",
+                     breaks=c("2","9"),
+                     labels=c("earnings-related",
+                              "flat-rate"))+
+   guides(fill=guide_legend(nrow=2,byrow=TRUE))+
+   annotate("text", x=1.5, y=117.5, label= p,size=5)+
+   theme_bw()+
+   theme(panel.border=element_blank(),axis.line=element_line(),legend.text = element_text(size = 14),
+         legend.title = element_text(size=14),axis.text=element_text(size=12),
+         axis.title=element_text(size=14),axis.text.x = element_blank(),legend.position="none"
+   )

> #Comparison 2
> #Situations
> #8-13
> 
> sit1<-dfSub_self$situation==8

> sit2<-dfSub_self$situation==13

> s1 <- dfSub_self$give_weight[sit1]

> s2 <- dfSub_self$give_weight[sit2]

> mean(dfSub_self$give_weight[sit1],na.rm=T)-
+   mean(dfSub_self$give_weight[sit2],na.rm=T)
[1] -5.001574

> #Nonparametric test statistics
> p<-wilcoxsign_test(s1~s2,data=dfSub_self,
+                    distribution="approximate") 

> p<-paste("p =",as.character(round(pvalue(p),4)), sep=" ")

> g2<-ggplot(data=dfSub_self[sit1|sit2,], 
+            aes(x=factor(situation), give_weight))+
+   #geom_violin()+
+   geom_boxplot(aes(fill=factor(situation)),width=.5,alpha=.8)+
+   stat_summary(fun.y = mean, geom="point",color="white",size=3) +
+   ylab("") +  xlab ("")+ 
+   ggtitle("(b) Inequality and\nhigh replacement")+
+   ylim(c(0,120))+
+   scale_fill_manual(values=c("#CCCCCC","#666666"), 
+                     name="",
+                     breaks=c("8","13"),
+                     labels=c("earnings-related",
+                              "flat-rate"))+
+   guides(fill=guide_legend(nrow=2,byrow=TRUE))+
+   annotate("text", x=1.5, y=117.5, label= p,size=5)+
+   theme_bw()+
+   theme(panel.border=element_blank(),axis.line=element_line(),legend.text = element_text(size = 14),
+         legend.title = element_text(size=14),axis.text=element_text(size=12),
+         axis.title=element_text(size=14),axis.text.x = element_blank(),axis.text.y=element_blank(),
+         legend.position="none"
+   )

> #Comparison 3
> #Situations
> #6-13
> 
> sit1<-dfSub_self$situation==6

> sit2<-dfSub_self$situation==13

> s1 <- dfSub_self$give_weight[sit1]

> s2 <- dfSub_self$give_weight[sit2]

> mean(dfSub_self$give_weight[sit1],na.rm=T)-
+   mean(dfSub_self$give_weight[sit2],na.rm=T)
[1] -2.77876

> #nonparametric test statistics
> p<-wilcoxsign_test(s1~s2,data=dfSub_self,
+                    distribution="exact") 

> p<-paste("p =",as.character(round(pvalue(p),4)), sep=" ")

> g3<-ggplot(data=dfSub_self[sit1|sit2,], 
+            aes(x=factor(situation), give_weight))+
+   #geom_violin()+
+   geom_boxplot(aes(fill=factor(situation)),width=.5,alpha=.8)+
+   stat_summary(fun.y = mean, geom="point",color="white",size=3) +
+   ylab("") +  xlab ("")+ ylim(c(0,120))+
+   ggtitle("(c) Inequality and\nlow replacement")+
+   theme_minimal()+
+   scale_fill_manual(values=c("#CCCCCC","#666666"), 
+                     name="",
+                     breaks=c("6","13"),
+                     labels=c("earnings-related",
+                              "flat-rate"))+
+   guides(fill=guide_legend(nrow=2,byrow=TRUE))+
+   annotate("text", x=1.5, y=117.5, label= p,size=5)+
+   theme_bw()+
+   theme(panel.border=element_blank(),axis.line=element_line(),legend.text = element_text(size = 14),
+         legend.title = element_text(size=14),axis.text=element_text(size=12),
+         axis.title=element_text(size=14),axis.text.x = element_blank(),axis.text.y=element_blank(),
+         legend.position="none"
+   )

> ##########################
> #Figure D.18: Effect of social insurance principle on transfers among selfish participants.
> ##########################
> 
> ggarrange(g1,g2, g3,common.legend = TRUE, legend="bottom",ncol = 3)

> ggsave(file="figure_d18.pdf", height = 5.83, width = 8.27, units = "in")
